home *** CD-ROM | disk | FTP | other *** search
/ Wayzata's Best of Shareware PC/Windows 1 / Wayzata's Best of Shareware for PC-Windows - Release 1 - Wayzata Technology (1993).iso / mac / DOS / PROGRAMG / FORTHCMP / MULTID.4TH < prev    next >
Text File  |  1992-03-30  |  15KB  |  578 lines
  1. \ ForthCMP  Multitasking Module
  2. \ Copyright 1985 (C) By Thomas Almy.  All rights reserved.
  3.  
  4. \ Permission is granted to registered users of ForthCMP to sell or distribute
  5. \ computer programs incorporating the compiled contents of this file.
  6.  
  7. \ This module writes direct to the display for terminal I/O
  8.  
  9.  
  10. .( LOADING MULTID) CR
  11. INCLUDE INTS
  12. INCLUDE FARMEM1
  13. 10 HEX
  14.  
  15. \ If EGA is defined non-zero then 43 line EGA code is generated
  16. FIND EGA #IF DROP #ELSE 0 CONSTANT EGA  0 CONSTANT VID-DELAY #THEN
  17.  
  18. EGA NOT #IF VARIABLE crtport  3D4 crtport ! #THEN
  19.  
  20. \ If VID-DELAY is defined non-zero then anti-snow code is added
  21. FIND VID-DELAY #IF DROP #ELSE 0 CONSTANT VID-DELAY #THEN
  22.  
  23. VARIABLE vidseg     \ VIDEO SEGMENT
  24. B800 vidseg !
  25. 50 CONSTANT c/l     \ Characters per line
  26. EGA #IF 2B #ELSE 19 #THEN
  27.    CONSTANT l/s     \ lines per screen
  28.  
  29.  
  30. DECIMAL  
  31. 0 0 IN/OUT NEED SINGLE 
  32. 0 0 IN/OUT NEED MULTI
  33. 0 0 IN/OUT NEED PAUSE
  34. 0 0 IN/OUT NEED end-timer
  35. 0 0 IN/OUT NEED start-timer
  36. 0 0 IN/OUT NEED CLS
  37.  
  38.  
  39. VARIABLE ?multi         \ true if multitasking turned on
  40. VARIABLE user           \ disp into user segment--used at comp time
  41. VARIABLE CTASK          \ pointer to task list
  42. VARIABLE inexpect       \ executing EXPECT -- only one at a time, please!
  43.  
  44.  \ Semaphores
  45.  
  46. 1 0 IN/OUT
  47. : SEMA BEGIN DUP @ WHILE PAUSE REPEAT ON ;
  48.  
  49. 1 0 IN/OUT
  50. : PHORE  OFF PAUSE ;
  51.  
  52.  
  53. 0 0 IN/OUT 
  54. : BYE  unsetup-vid end-timer bye ;
  55.  
  56.  \ Memory management interface
  57. 1 1 IN/OUT
  58. : GET malloc IF    ." OUT OF MEMORY " BYE THEN ;
  59.  
  60.  \ USER VARIABLES 
  61. H: UALLOT  DSEG user @  +  user ! ;
  62. 1 2 IN/OUT
  63. H: UCREATE user @ CONSTANT ;
  64. H: UVARIABLE UCREATE 2 UALLOT ;
  65. H: URESET DSEG  0 user ! ;
  66. URESET
  67.  \ redefinition of primitive I/O functions
  68. HEX
  69. 1 0 IN/OUT
  70. : storecursor ( DISPL -- )  CTASK @ 12 + CS: ! ;
  71.  
  72. 1 0 IN/OUT
  73. : setcursor (  DISPL -- )  
  74. EGA #IF
  75.     2/ DUP 0F 3D4 PC! 3D5 PC! >< 0E 3D4 PC! 3D5 PC! 
  76. #ELSE
  77.     2/ DUP 0F crtport @ PC! crtport @ 1+ PC!
  78.     >< 0E crtport @ PC! crtport @ 1+ PC! 
  79. #THEN
  80. ;
  81.  
  82. 0 0 IN/OUT
  83. : nocursor  l/s c/l * 2* 1- setcursor ( OFF SCREEN ! ) ;
  84.  
  85. 2 0 IN/OUT
  86. : GOTOXY  c/l * + 2*  storecursor ;
  87.  
  88.  
  89. EGA #IF
  90. 0 0 IN/OUT
  91. CODE set-ega
  92.     03 # AX MOV  10 INT                     \ SET MODE 3
  93.     1112 # AX MOV  0 # BL MOV  10 INT       \ Load 8X8 font
  94.     1200 # AX MOV  20 # BL MOV  10 INT      \ Load new printscreen
  95.     1 # AH MOV  707 # CX MOV  10 INT        \ LOAD CURSOR SCAN LINES
  96.     3D4 # DX MOV  0A # AL MOV  [DX] BYTE OUT \ set cursor 
  97.     FWD, THEN,
  98.     DX INC
  99.     6 # AL MOV  [DX] OUT
  100.     RET
  101. END-CODE
  102.  
  103. 0 0 IN/OUT
  104. CODE unset-ega
  105.     03 # AX MOV  10 INT  RET  END-CODE
  106. #THEN 
  107.  
  108. 0 0 IN/OUT
  109. : setup-vid
  110. EGA #IF
  111.     set-ega
  112.     CTASK @ 12 + CS: OFF    \ home cursor
  113. #ELSE
  114.     40 49 C@L 7 = IF 3B4 crtport ! B000 vidseg ! THEN \ MONOCHROME
  115.     40 50 C@L 40 51 C@L GOTOXY
  116.     vidseg @  c/l l/s 1- * 2* 1+ C@L  CTASK @ 14 + CS: ! 
  117. #THEN
  118. ;
  119.  
  120.  CODE unsetup-vid  
  121. EGA #IF
  122.     CALL' CLS
  123.     CALL' unset-ega
  124.     DX DX XOR
  125. #ELSE
  126.     CTASK [] BX MOV
  127.     CS: 12 +[BX] AX MOV  \ cursor offset
  128.     c/l # BX MOV 
  129.     DX DX XOR
  130.     AX 1 SAR  
  131.     BX IDIV
  132.     AL DH MOV  
  133. #THEN
  134.     2 # AH MOV 
  135.     BH BH XOR  
  136.     10 INT  
  137.     RET 
  138. END-CODE \ unsetup-vid
  139.  
  140. CODE scrmove  ( source dest wordCount -- )
  141.     BX POP 
  142.     CX POP
  143.     DI POP
  144.     SI POP
  145.     LOOP IF,
  146.         DS PUSHSEG
  147. VID-DELAY #IF  
  148.         B800 # vidseg [] CMP  =0 IF,
  149.             3DA # DX MOV
  150.             BEGIN,  
  151.                 BYTE [DX] IN  
  152.                 8 # AL TEST  
  153.             =0 ~ UNTIL,
  154.             DX DEC
  155.             DX DEC
  156.             21 # AL MOV
  157.             BYTE [DX] OUT
  158.         THEN, 
  159. #THEN
  160.         vidseg [] AX MOV
  161.         AX DS >SEG
  162.         AX ES >SEG
  163.         REPZ MOVS
  164.         DS POPSEG
  165. VID-DELAY #IF
  166.         B800 # vidseg [] CMP  =0 IF,
  167.             3D8 # DX MOV
  168.             29 # AL MOV
  169.             BYTE [DX] OUT
  170.         THEN, 
  171. #THEN
  172.     THEN, 
  173.     BX JMPI 
  174. END-CODE \ scrmove
  175.  
  176. 2 0 IN/OUT
  177. CODE scrfill ( source wordCount -- )
  178.     vidseg [] ES >SEG
  179.     20 # BYTE ES: [BX] MOV
  180.     CTASK [] DI MOV
  181.     CS: 14 +[DI] CL MOV  \ style
  182.     CL ES: 1 +[BX] MOV
  183.     BX PUSH
  184.     BX INC 
  185.     BX INC 
  186.     BX PUSH  
  187.     AX DEC 
  188.     AX PUSH
  189.     CALL' scrmove
  190.     RET
  191. END-CODE \ scrfill
  192.  
  193. 0 0 IN/OUT
  194. : scrollup  c/l 2*  0  c/l l/s 1- * scrmove
  195.     c/l l/s 1- * 2*  c/l    scrfill
  196.     c/l l/s 1- * 2*  CTASK @ 12 + CS: ! ( set cursor ) ;
  197.  
  198. 0 2 IN/OUT
  199. : ?XY     CTASK @ 12 + CS: @  2/  0 c/l UM/MOD ;
  200.  
  201. 1 0 IN/OUT
  202. : FOREGROUND 0F AND CTASK @ 14 + TUCK CS: @ F0 AND OR SWAP CS: ! ;
  203.  
  204. 1 0 IN/OUT
  205. : BACKGROUND 7 AND 4 << CTASK @ 14 + TUCK CS: @ 0F AND OR SWAP CS: ! ;
  206.  
  207.  
  208. : EMIT  
  209.     CTASK @ 12 + CS: @  c/l l/s * 2* >= IF scrollup THEN
  210.     vidseg @ CTASK @ 12 + CS: @ C!L
  211.     CTASK @ 14 + CS: @ vidseg @ CTASK @ 12 + CS: @ 1+ C!L
  212.     CTASK @ 12 + CS: @ 2+ storecursor  PAUSE ;
  213.  
  214. : CR
  215.     CTASK @ 12 + CS: @  
  216.     c/l 2*  U/  1+  c/l 2*  *
  217.     DUP c/l l/s * 2* = IF DROP scrollup  CTASK @ 12 + CS: @ THEN
  218.     storecursor  PAUSE ;
  219.  
  220. : SPACES
  221.     DUP 0> IF
  222.         c/l l/s * 2*  CTASK @ 12 + CS: @ - OVER 2* < IF ( too big )
  223.         0 DO BL EMIT LOOP ELSE
  224.             CTASK @ 12 + CS: @  SWAP 2DUP scrfill
  225.         2* + storecursor  PAUSE 
  226.         THEN 
  227.     ELSE   DROP
  228.     THEN
  229. ;
  230.  
  231.  
  232. 2 1 IN/OUT
  233. CODE (type) ( AX has count, BX has string, result is cursor position )
  234.     BX SI MOV
  235.     CTASK [] BX MOV
  236.     CS: 12 +[BX] DI MOV \ cursor
  237.     AX CX MOV
  238.     CS: 14 +[BX] AH MOV \ style
  239.     vidseg [] ES >SEG
  240.     LOOP IF, 
  241.         BEGIN,
  242.             BYTE LODS
  243.             STOS  
  244.         LOOP ~ UNTIL,
  245.     THEN,
  246.     DI AX MOV       \ final cursor position
  247.     RET
  248. END-CODE \ (type)
  249.  
  250. : TYPE 
  251.     c/l l/s * 2*  CTASK @ 12 + CS: @ - OVER 2* < IF ( too big )
  252.         0 ?DO COUNT EMIT LOOP DROP
  253.     ELSE 
  254.         (type) storecursor PAUSE 
  255.     THEN ;
  256.  
  257. 2 1 IN/OUT
  258. CODE (cs:type) ( AX has count, BX has string, result is cursor position)
  259.     BX SI MOV
  260.     CTASK [] BX MOV
  261.     CS: 12 +[BX] DI MOV \ cursor
  262.     AX CX MOV
  263.     CS: 14 +[BX] AH MOV \ style
  264.     vidseg [] ES >SEG
  265.     LOOP IF, 
  266.         BEGIN,
  267.             CS: BYTE LODS
  268.             STOS  
  269.         LOOP ~ UNTIL,
  270.     THEN,
  271.     DI AX MOV       \ final cursor position
  272.     RET
  273. END-CODE \ (cs:type)
  274.  
  275. : CS:TYPE 
  276.     c/l l/s * 2* CTASK @ 12 + CS: @ - OVER 2* < IF ( too big )
  277.         0 ?DO CS: COUNT EMIT LOOP DROP
  278.     ELSE 
  279.         (cs:type) storecursor PAUSE 
  280.     THEN ;
  281.  
  282.  
  283. 0 0 IN/OUT 
  284. : CLS  0  c/l l/s *  scrfill  0 storecursor ;
  285.  
  286. 0 1 IN/OUT
  287. CODE ?TERMINAL 
  288.     CALL' PAUSE     \ allow another task to execute
  289.     1 # AH MOV 
  290.     16 INT 
  291.     0 # AX MOV
  292.     =0 ~ IF, AX DEC  THEN,
  293.     RET
  294. END-CODE \ ?TERMINAL
  295.  
  296. : PAD CTASK @ 16 + CS: @ ;
  297.  
  298.  
  299. : KEY  BEGIN ?TERMINAL  CTASK @ 12 + CS: @ setcursor UNTIL  
  300.     0 8 BDOS 
  301.     PAUSE
  302.     nocursor ;
  303.  
  304.  \ EXPECT
  305. FIND SPAN #IF DROP #ELSE VARIABLE SPAN #THEN
  306.  
  307. 0 0 IN/OUT
  308. : bu  CTASK @ 12 + CS: @ 2- DUP storecursor BL EMIT storecursor -1 SPAN +! ;
  309.  
  310. DECIMAL
  311.  
  312. : EXPECT
  313.     inexpect SEMA       \ too hard if two or more tasks want input at once!
  314.     SPACE
  315.     >R SPAN OFF
  316.     BEGIN
  317.         SPAN @ R@ < WHILE       \ more room on line
  318.         KEY  CASE
  319.         27 OF BEGIN SPAN @ 0> WHILE bu REPEAT  ENDOF
  320.         8  OF SPAN @ 0> IF bu THEN ENDOF
  321.         13 OF BL EMIT
  322.               R> DROP DROP 
  323.               inexpect PHORE 
  324.               EXIT ENDOF
  325.         ( ELSE ) DUP EMIT 
  326.                  OVER SPAN @ + C! 
  327.                  1 SPAN +!
  328.         0 ENDCASE
  329.     REPEAT
  330.     inexpect PHORE
  331.     R> 2DROP ;
  332.  
  333.  
  334.  \ TASK CREATION 
  335. HEX
  336. H: TASK                          \ values after INIT-TASKS:
  337.    CSEG FORCE CREATE HERE E92E , \ DISP 0 -- JMP ( task asleep )
  338.    DSEG CTASK @ ,  CTASK !    \     02 -- relative addr nxt task
  339.    user @ ,                   \     04 -- size of user area (not used?)
  340.    0 ,                        \     06 -- SS register contents
  341.    user @ pssize 10 * + ,     \     08 -- SP register contents
  342.    user @ pssize 10 * + rssize + , \     0A -- BP register contents
  343.    ,                          \     0C -- PC contents
  344. \ the following fields are for per-task variables
  345. \ and could be selectively elimiated if not needed if space is 
  346. \ at a premium.  In that case, offsets may need to be adjusted
  347. \ for words which use latter fields.
  348.    0 ,                        \     0E -- Message list
  349.    0 ,                        \     10 -- Timer
  350.    0 ,                        \     12 -- Cursor location
  351.    7 ,                        \     14 -- character attribute (style)
  352.    DSEG HERE 80 ALLOT 20 + ,  \     16 -- PAD, a per-task work area
  353. ; 
  354. 0 #IF
  355. Initially, DISP 2 has absolute address of next task.
  356. This values as well as DISP 6 get
  357. filled in by INIT-TASKS when application is run.
  358. #THEN
  359.  
  360. CSEG FORCE  HERE  CREATE MAIN-TASK  \ Give it a name
  361. DSEG CTASK !                    \ Task list points to it
  362. 80CD ,                          \ DISP 0 -- INT 80 (task awake)
  363.    0 ,                          \ 02 -- relative addr next task
  364.    0 ,                          \ 04 -- NOT USED
  365.    0 ,                          \ 06 -- SS register contents
  366.    0 ,                          \ 08 -- SP register contents
  367.    0 ,                          \ 0A -- BP register contents
  368.    0 ,                          \ 0C -- PC contents
  369.    0 ,                          \ 0E -- Message list
  370.    0 ,                          \ 10 -- Timer
  371.    0 ,                          \ 12 -- Cursor Location
  372.    7 ,                          \ 14 -- Style
  373.    DSEG HERE 80 ALLOT 20 + ,    \ 16 -- PAD, a per-task work area
  374. 0 #IF
  375. DISP-2, 6, and 12 get filled in by INIT-TASK.  -8 -0A and -0C
  376. are filled by first task swap (which is done by INIT-TASK).
  377. #THEN
  378.  
  379.  \ TASK INITIALIZATION
  380. 0 0 IN/OUT 
  381. : INIT-TASKS \ This MUST be executed to start multitasking
  382.     CTASK @
  383.     BEGIN ?DUP WHILE  \ for each task DO:
  384.         2+ DUP CS: @ IF  \ one follows, this isnt main task
  385.             DUP 8 + CS: @ 10 + 4 >>  GET 
  386.          OVER 4 + CS: ! \ stackseg
  387.             DUP CS: @ TUCK   \ next task
  388.         ELSE
  389.             0 SWAP CTASK @ \ next task is head of list
  390.         THEN
  391.         OVER - 2- SWAP CS: !  
  392.     REPEAT
  393.     MAIN-TASK CTASK !  
  394.     setup-vid
  395.     ?SS: MAIN-TASK 6 + CS: !    \ sets main task stack segment
  396.     start-timer
  397.     MULTI ( GO!!! ) ;
  398.  
  399.  \ TASK DISPATCHER
  400. CODE PAUSE  
  401.     0 # ?multi [] CMP  
  402.     =0 IF, RET THEN,
  403.     CTASK [] BX MOV         \ current task
  404.     CS: 0C +[BX] POP        \ save PC
  405.     BP CS: 0A +[BX] MOV     \ save BP
  406.     SP CS: 08 +[BX] MOV     \ save SP
  407.     CS: 2 +[BX] BX ADD  
  408.     4 # BX ADD  
  409.     CLI                \ no ints during dispatch!
  410.     BX JMPI  ( dispatch )
  411. END-CODE \ PAUSE
  412.  
  413. 0 #IF
  414. Tasks are linked together so that jumping to a task will cause
  415. jumping to the next if it is asleep, or doing an INT 80 if it
  416. is awake.  Thanks to Henry Laxen's Forth 83 model for the
  417. technique.
  418. #THEN
  419.  
  420. L: start-task ( the INT80 routine )  
  421.     BX POP 
  422.     BX DEC 
  423.     BX DEC                  \ Pointer to the task
  424.     CS: 6 +[BX] SS >SEG     \ restore stack segment
  425.     CS: 8 +[BX] SP MOV      \ restore SP
  426.     STI                     \ Interrupts are safe now
  427.     CS: 0A +[BX] BP MOV     \ restore BP
  428.     BX  CTASK [] MOV        \ current task
  429.     CS: 0C +[BX] JMPI       \ go!
  430. FORTH \ start-task 
  431. 0 #IF
  432. This code starts up a new task by setting up all registers,
  433. fixing CTASK and USERP, and jumping to where we left off.
  434. #THEN
  435.  
  436.  \ TASK MANAGEMENT
  437. : SINGLE  ?multi OFF ;
  438.  
  439. : MULTI   ?multi ON
  440.     ?CS: start-task 80 set-handler  \ install interrupt vector
  441.     PAUSE  \ start with a task swap
  442. ;
  443.  
  444. 1 0 IN/OUT
  445. : WAKE  80CD CS: <- ;
  446.  
  447. 1 0 IN/OUT
  448. \ the 2e prefix byte (CS override) makes the jmp instruction 4 bytes long
  449. : SLEEP (  task -- )   E92E CS: <- ;
  450.  
  451. 1 1 IN/OUT
  452. : WAITING?  10 + CS: @ 0<> ;
  453.  
  454. 0 0 IN/OUT
  455. : STOP  CTASK @ SLEEP PAUSE ;
  456.  
  457. 0 1 IN/OUT
  458. : ACTIVE-TASKS
  459.     0 MAIN-TASK
  460.     BEGIN
  461.         DUP WAITING? IF SWAP 1+ SWAP ELSE 
  462.             DUP CS: @ 80CD = IF SWAP 1+ SWAP THEN THEN \ check for active
  463.         DUP 2+ CS: @ + 4 + \ address of next task
  464.     DUP MAIN-TASK = UNTIL     \ Loop until back to start
  465.     DROP ( task address )
  466. ;
  467.  
  468.  \ MESSAGE PASSING
  469. 0 1 IN/OUT
  470. : MESSAGE?  CTASK @ 0E + CS: @ ;
  471.  
  472. 0 1 IN/OUT
  473. : GET-MESSAGE  
  474.   BEGIN MESSAGE? ?DUP 0= WHILE STOP REPEAT
  475.   DUP  0 @L  CTASK @ 0E + CS: !  \ Unlink message
  476. ;   
  477.  
  478. 1 1 IN/OUT
  479. : MESSAGES 
  480.     0 SWAP 0E + CS: @ ?DUP IF
  481.         BEGIN SWAP 1+ SWAP  0 @L  ?DUP 0= UNTIL
  482.     THEN ;
  483.  
  484. 2 0 IN/OUT
  485. : SEND-MESSAGE 
  486.     OVER 0 SWAP 0 !L        \ set message's next field to NIL
  487.     DUP WAITING? NOT IF DUP WAKE THEN \ fire up receiving task
  488.                                 \ unless waiting for timer
  489.     0E + DUP CS: @ ?DUP IF  \ Existing messages in queue
  490.         NIP
  491.         BEGIN DUP 0 @L ?DUP WHILE NIP REPEAT \ find end of list
  492.         0 !L  \ store message at end of list
  493.     ELSE
  494.         CS: !     \ no existing messages, put at head of queue.
  495.     THEN
  496.     PAUSE ;  \ Give it a chance to run
  497.  
  498.  \ control-break handler
  499. \ always gets control and (currently) dumps task information
  500.  
  501. 2VARIABLE cb_save
  502.  
  503. 1B CONSTANT cb_int
  504.  
  505. 0 0 IN/OUT
  506. : cbt  
  507.     CLS 
  508.     SINGLE
  509.     end-timer
  510.     ." Task statistics: "
  511.     MAIN-TASK \ start with first
  512.     BEGIN CR
  513.         HEX DUP 0 <# # # # # #> TYPE SPACE \ address
  514.         DUP WAITING? IF ." Waiting " DUP 10 + CS: @ . ." ticks" ELSE 
  515.             DUP CS: @ 80CD = IF ." Active" ELSE ." Sleeping" THEN THEN 
  516.         DUP 2+ CS: @ + 4 + \ address of next task
  517.     DUP MAIN-TASK = UNTIL     \ Loop until back to start
  518.     DROP ( task address )
  519. EGA #IF
  520.     CR ." Hit any key when finished"    KEY DROP
  521. #THEN
  522.     unsetup-vid
  523.     bye
  524. ;
  525.  
  526.  
  527. ' cbt TASK cb-task
  528.  
  529.  
  530. L: cb_handler ( actual interrupt handler )
  531.       80CD # CS: cb-task [] MOV \ wake cb task
  532.     STI
  533.     IRET FORTH
  534.  
  535.  
  536.  \ timer
  537. 1C CONSTANT t_int               \ timer interupt vector number
  538. CSEG FORCE 
  539. CREATE t_save 4 ALLOT           \ original interupt vector
  540. L: t_handler
  541.     PUSHF CS: t_save CALLF    \ do original functions
  542.     BX PUSH
  543.     MAIN-TASK # BX MOV ( start of list )
  544.     BEGIN,  
  545.         CS: 0 # 10 +[BX] CMP =0 ~ IF, ( non_zero time )
  546.             CS: 10 +[BX] DEC  ( count down )
  547.             =0 IF, 80CD # CS: [BX] MOV THEN, ( wake task )
  548.         THEN,
  549.         CS: 2 +[BX] BX ADD 
  550.         4 # BX ADD ( next task )
  551.         MAIN-TASK # BX CMP  
  552.     =0 UNTIL, ( back at start? )
  553.     BX POP 
  554.     IRET
  555. FORTH \ t_handler
  556.  
  557. \ timer start and end                          08:09 11/18/85
  558.  
  559. : start-timer  \ and control break handler
  560.     t_int get-handler  t_save CS: 2!
  561.     ?CS: t_handler t_int set-handler
  562.     cb_int get-handler cb_save 2!
  563.     ?CS: cb_handler cb_int set-handler
  564. ;
  565.  
  566. : end-timer
  567.     t_save CS: 2@  t_int set-handler
  568.     cb_save 2@ cb_int set-handler
  569. ;
  570.  
  571. 2 0 IN/OUT
  572. : TIME-OUT ( ticks task -- )  DUP SLEEP 10 + CS: ! ;
  573.  
  574. 1 0 IN/OUT
  575. : WAIT ( ticks -- ) CTASK @ TIME-OUT PAUSE ;
  576.  
  577. DSEG 0A = #IF DECIMAL #THEN
  578.